Baraj Sibiu, august 1996, ziua 3
Problema 1 (Bilute - Adrian Nita)

Fie doua canale circulare ce se intersecteaza. Aceste canale contin bile albe 
si negre, precum si doua de culoare gri, asfel incat canalele sa fie pline.
Bilele se pot roti in cele doua canale doar in sensul miscarii acelor de 
ceasornic.
Scopul jocului consta in a aranja bilele astfel incat la final in canalul 
circular din stanga sa fie doar bile albe, in cel din dreapta doar negre, iar la 
intersectia canalelor circulare sa fie plasate bilele gri (vezi figura de jos).
Intrarea consta in grupe de cate doua siruri citite din fisierul "bile.txt", 
siruri ce semnifica pozitia bilelor in cele doua canale circulare, incepand cu 
bila aflata la intersectia de jos a canalelor, citirea facandu-se in sens orar.
Iesirea consta in grupe de cate n perechi, scrise in fisierul "bile.sol",  de 
forma:
	s1 d1
	s2 d2 
	........
	sn dn
	n

unde si reprezinta numarul de rotiri de cate o bila in cercul din stanga, urmat 
de di numarul de rotiri de cate o bila in cel din dreapta, iar n trebuie sa fie 
minim.
==========================================
Testul 1:
AAAAAAAGANAGA
ANNNNNNNNANNN
------------------------
testul 2:
AAAAAGANAGAAA
ANNNGNNNNANNN
---------------------
testul 3:
AGAANGNNNANAA
AANNANNANAAAN
----------------------
Testul 4:
AAAANAAANAAAG
ANNNANNNGNNNA
---------------------
Testul 5:
NNNANGNAAANNA
NNNAAAANAAANG
-----------------------
testul 6:
AAAAAAAAAGNAA
AGNNGNNNNNNNN
---------------------
Testul 7:
GAAAAAAAAGAAA
GNNNGNNNNNNNN
----------------------
Solutie (Sergiu Stefanov - cea mai buna din concurs)
{$A+,B-,D+,E-,F-,G+,I+,L+,N+,O-,P-,Q+,R-,S-,T-,V+,X+,Y+}
{$M 64000,64000,655360}
Program Problema1_Stefanov;

Uses
  Crt;

Type
  Conf=Array[1..13] of Char;

Var
  Fi,Fo:Text;
  A,B:Conf;
  i,j:Byte;
  Mw,Ad,Adc:Integer;
  Sw1:Boolean;
  sa,sb:Array[1..20] of Conf;
  s,d:Array[1..20] of Byte;

Procedure RoteS;

Var
  i:Byte;
  k:Char;

Begin
  k:=A[13];
  For i:=13 downto 2 do
    A[i]:=A[i-1];
  A[1]:=k;
  B[1]:=A[1];
  B[5]:=A[10]
End;

Procedure RoteD;

Var
  i:Byte;
  k:Char;

Begin
  k:=B[13];
  For i:=13 downto 2 do
    B[i]:=B[i-1];
  B[1]:=k;
  A[1]:=B[1];
  A[10]:=B[5]
End;

Function Sol:Boolean;

Var
  i:Byte;

Begin
  If A[1]<>'G' then
    Begin
      Sol:=False;
      Exit
    End;
  If A[10]<>'G' then
    Begin
      Sol:=False;
      Exit
    End;
  For i:=2 to 9 do
    If A[i]<>'A' then
      Begin
        Sol:=False;
        Exit
      End;
  For i:=11 to 13 do
    If A[i]<>'A' then
      Begin
        Sol:=False;
        Exit
      End;
  Sol:=True
End;

Function Arr:Boolean;

Var
  i:Integer;

Begin
 { For i:=1 to Mw-1 do
    If (A=Sa[i]) and (B=Sb[i]) then
      Begin
        Arr:=True;
        Exit
      End;}
  Arr:=False
End;

Procedure RotS(Sw:Boolean);forward;

Procedure RotD(Sw:Boolean);

Var
  i:Byte;

Begin
  If Sol then
    Begin
      For i:=1 to Adc do
        WriteLn(Fo,S[i],' ',D[i]);
      WriteLn(Fo,Adc);
      Sw1:=True;
    End
  else
    Begin
      If Adc>Ad then Exit;
      D[Adc]:=0;
      Inc(Mw);
     { Sa[Mw]:=A;
      Sb[Mw]:=B;}
      If Sw then
        RotS(False);
      If Sw1 then Exit;
      For i:=1 to 12 do
        Begin
          D[Adc]:=i;
          RoteD;
         { Sb[Mw]:=B;}
          RotS(True);
          If Sw1 then Exit
        End;
      RoteD;
      D[Adc]:=0;
      Dec(Mw)
    End;
End;

Procedure RotS;

Var
  i:Byte;

Begin
  Inc(Adc);
  If Sol then
    Begin
      For i:=1 to Adc-1 do
        WriteLn(Fo,S[i],' ',D[i]);
      WriteLn(Fo,Adc-1);
      Sw1:=True;
    End
  else
    Begin
      If (Adc>Ad) then
        Begin
          Dec(Adc);
          Exit
        End;
      S[Adc]:=0;
      Inc(Mw);
     { Sa[Mw]:=A;
      Sb[Mw]:=B;}
      If Sw then
        RotD(False);
      If Sw1 then Exit;
      For i:=1 to 12 do
        Begin
          S[Adc]:=i;
          RoteS;
         { Sa[Mw]:=A;}
          RotD(True);
          If Sw1 then Exit
        End;
      RoteS;
      S[Adc]:=0;
      Dec(Mw)
    End;
  Dec(Adc)
End;

Begin
  ClrScr;
  Assign(Fi,'bile.txt');
  ReSet(Fi);
  Assign(Fo,'bile.sol');
  ReWrite(Fo);
  For i:=1 to 13 do
    Read(Fi,A[i]);
  ReadLn(Fi);
  For i:=1 to 13 do
    Read(Fi,B[i]);
  Sw1:=False;
  For Ad:=0 to 20 do
    Begin
      RotS(True);
      If Sw1 then
        Begin
          Close(Fo);
          Exit
        End
    End;
  Close(Fi);
End.
----------------------
Solutia 2 (Mihai Stroe)
    Problema este exponentiala; datorita numarului mare de variante: (13^2)^n.
  De aceea, orice program poate analiza un numar mic de variante. Rezolvarea
  aleasa de mine analizeaza toate variantele in una sau doua mutari, dar nu
  termina de analizat variantele in trei mutari. O strategie Branch & Bound
  se implementeaza greu, datorita necesitatii unei euristici performante,
  care sa elimine suficiente cazuri. Heap-ul este insuficient (o configuratie
  are minim 24 octeti, deci in heap pot 'intra' maxim mai putin de 30000
  configuratii, numar infim (169*169<29000), care poate acoperi cam doua
  mutari, daca nu se foloseste o euristica performanta.
var fi,fo:text;
    i,j,nr,k,l,m,n:longint;
    s:string;
    st,dr:array[1..10]of byte;
    c:char;
    s1,ss1,s2,ss2:string[13];
    ss,sd:array[0..10]of string[13];

procedure readdata;
begin
  readln(fi,s1);
  readln(fi,s2);
end;

procedure rst(var ss1,ss2:string);
begin
  c:=ss1[n];
  for i:=12 downto 1 do
      ss1[i+1]:=ss1[i];
  ss1[1]:=c;
  ss2[1]:=ss1[1];
  ss2[5]:=ss1[10];
end;

procedure rdr(var ss1,ss2:string);
begin
  c:=ss2[n];
  for i:=12 downto 1 do
      ss2[i+1]:=ss2[i];
  ss2[1]:=c;
  ss1[1]:=ss2[1];
  ss1[10]:=ss2[5];
end;

function solutie(ss1,ss2:string):boolean;
begin
  solutie:=((ss1='GAAAAAAAAGAAA')and(ss2='GNNNGNNNNNNNN'));
end;

procedure writesol(k:longint);
begin
  for i:=1 to k do
      writeln(fo,st[i],' ',dr[i]);
  writeln(fo,k);
  close(fo);close(fi);
  halt;
end;

procedure rec(k:longint);
var i,j,l:longint;sx,sy:string;
begin
  if k=nr+1 then if solutie(ss[k-1],sd[k-1]) then begin writesol(k-1);exit;end;
  if k=nr+1 then exit;
  sx:=ss[k-1];
  sy:=sd[k-1];
  for i:=0 to 12 do
      for j:=0 to 12 do
          if(k<>1)or(i+j<>0) then
          begin
            if (i<>0)and(j=0) then
               begin
                 sx:=ss[k-1];
                 sy:=sd[k-1];
                 for l:=1 to i do rst(sx,sy);
               end;
            if j<>0 then rdr(sx,sy);
            ss[k]:=sx;
            sd[k]:=sy;
            st[k]:=i;
            dr[k]:=j;
            rec(k+1);
          end;
end;

procedure solve;
begin
  if solutie(s1,s2) then
     begin
       writeln(fo,0);
       exit;
     end;
  for nr:=1 to 4 do
      begin
        ss[0]:=s1;
        sd[0]:=s2;
        rec(1);
      end;
end;
begin
  n:=13;
  readln(s);
  assign(fi,s);
  reset(fi);
  assign(fo,'');
  rewrite(fo);
  readdata;
  solve;
  close(fi);
  close(fo);
end.
-----------------------
